home *** CD-ROM | disk | FTP | other *** search
/ HyperLib 1997 Winter - Disc 1 / HYPERLIB-1997-Winter-CD1.ISO.7z / HYPERLIB-1997-Winter-CD1.ISO / オンラインウェア / PRG / MacPerl 506 appl folder.sit / MacPerl 506 appl folder / Mac_Perl_506r1m_appl / lib / termcap.pl < prev    next >
Text File  |  1995-03-20  |  4KB  |  170 lines
  1. ;# $RCSfile: termcap.pl,v $$Revision: 4.1 $$Date: 92/08/07 18:24:16 $
  2. ;#
  3. ;# Usage:
  4. ;#    require 'ioctl.pl';
  5. ;#    ioctl(TTY,$TIOCGETP,$foo);
  6. ;#    ($ispeed,$ospeed) = unpack('cc',$foo);
  7. ;#    require 'termcap.pl';
  8. ;#    &Tgetent('vt100');    # sets $TC{'cm'}, etc.
  9. ;#    &Tputs(&Tgoto($TC{'cm'},$col,$row), 0, 'FILEHANDLE');
  10. ;#    &Tputs($TC{'dl'},$affcnt,'FILEHANDLE');
  11. ;#
  12.  
  13. die "termcap.pl not (yet) implemented on the Mac";
  14.  
  15. sub Tgetent {
  16.     local($TERM) = @_;
  17.     local($TERMCAP,$_,$entry,$loop,$field);
  18.  
  19.     warn "Tgetent: no ospeed set" unless $ospeed;
  20.     foreach $key (keys(TC)) {
  21.     delete $TC{$key};
  22.     }
  23.     $TERM = $ENV{'TERM'} unless $TERM;
  24.     $TERM =~ s/(¥W)/¥¥$1/g;
  25.     $TERMCAP = $ENV{'TERMCAP'};
  26.     $TERMCAP = '/etc/termcap' unless $TERMCAP;
  27.     if ($TERMCAP !~ m:^/:) {
  28.     if ($TERMCAP !~ /(^|¥|)$TERM[:¥|]/) {
  29.         $TERMCAP = '/etc/termcap';
  30.     }
  31.     }
  32.     if ($TERMCAP =~ m:^/:) {
  33.     $entry = '';
  34.     do {
  35.         $loop = "
  36.         open(TERMCAP,'<$TERMCAP') || die ¥"Can't open $TERMCAP¥";
  37.         while (<TERMCAP>) {
  38.         next if /^#/;
  39.         next if /^¥t/;
  40.         if (/(^|¥¥|)${TERM}[:¥¥|]/) {
  41.             chop;
  42.             while (chop eq '¥¥¥¥') {
  43.             ¥$_ .= <TERMCAP>;
  44.             chop;
  45.             }
  46.             ¥$_ .= ':';
  47.             last;
  48.         }
  49.         }
  50.         close TERMCAP;
  51.         ¥$entry .= ¥$_;
  52.         ";
  53.         eval $loop;
  54.     } while s/:tc=([^:]+):/:/ && ($TERM = $1);
  55.     $TERMCAP = $entry;
  56.     }
  57.  
  58.     foreach $field (split(/:[¥s:¥¥]*/,$TERMCAP)) {
  59.     if ($field =~ /^¥w¥w$/) {
  60.         $TC{$field} = 1;
  61.     }
  62.     elsif ($field =~ /^(¥w¥w)#(.*)/) {
  63.         $TC{$1} = $2 if $TC{$1} eq '';
  64.     }
  65.     elsif ($field =~ /^(¥w¥w)=(.*)/) {
  66.         $entry = $1;
  67.         $_ = $2;
  68.         s/¥¥E/¥033/g;
  69.         s/¥¥(¥d¥d¥d)/pack('c',$1 & 0177)/eg;
  70.         s/¥¥n/¥n/g;
  71.         s/¥¥r/¥r/g;
  72.         s/¥¥t/¥t/g;
  73.         s/¥¥b/¥b/g;
  74.         s/¥¥f/¥f/g;
  75.         s/¥¥¥^/¥377/g;
  76.         s/¥^¥?/¥177/g;
  77.         s/¥^(.)/pack('c',ord($1) & 31)/eg;
  78.         s/¥¥(.)/$1/g;
  79.         s/¥377/^/g;
  80.         $TC{$entry} = $_ if $TC{$entry} eq '';
  81.     }
  82.     }
  83.     $TC{'pc'} = "¥0" if $TC{'pc'} eq '';
  84.     $TC{'bc'} = "¥b" if $TC{'bc'} eq '';
  85. }
  86.  
  87. @Tputs = (0,200,133.3,90.9,74.3,66.7,50,33.3,16.7,8.3,5.5,4.1,2,1,.5,.2);
  88.  
  89. sub Tputs {
  90.     local($string,$affcnt,$FH) = @_;
  91.     local($ms);
  92.     if ($string =~ /(^[¥d.]+)(¥*?)(.*)$/) {
  93.     $ms = $1;
  94.     $ms *= $affcnt if $2;
  95.     $string = $3;
  96.     $decr = $Tputs[$ospeed];
  97.     if ($decr > .1) {
  98.         $ms += $decr / 2;
  99.         $string .= $TC{'pc'} x ($ms / $decr);
  100.     }
  101.     }
  102.     print $FH $string if $FH;
  103.     $string;
  104. }
  105.  
  106. sub Tgoto {
  107.     local($string) = shift(@_);
  108.     local($result) = '';
  109.     local($after) = '';
  110.     local($code,$tmp) = @_;
  111.     local(@tmp);
  112.     @tmp = ($tmp,$code);
  113.     local($online) = 0;
  114.     while ($string =~ /^([^%]*)%(.)(.*)/) {
  115.     $result .= $1;
  116.     $code = $2;
  117.     $string = $3;
  118.     if ($code eq 'd') {
  119.         $result .= sprintf("%d",shift(@tmp));
  120.     }
  121.     elsif ($code eq '.') {
  122.         $tmp = shift(@tmp);
  123.         if ($tmp == 0 || $tmp == 4 || $tmp == 10) {
  124.         if ($online) {
  125.             ++$tmp, $after .= $TC{'up'} if $TC{'up'};
  126.         }
  127.         else {
  128.             ++$tmp, $after .= $TC{'bc'};
  129.         }
  130.         }
  131.         $result .= sprintf("%c",$tmp);
  132.         $online = !$online;
  133.     }
  134.     elsif ($code eq '+') {
  135.         $result .= sprintf("%c",shift(@tmp)+ord($string));
  136.         $string = substr($string,1,99);
  137.         $online = !$online;
  138.     }
  139.     elsif ($code eq 'r') {
  140.         ($code,$tmp) = @tmp;
  141.         @tmp = ($tmp,$code);
  142.         $online = !$online;
  143.     }
  144.     elsif ($code eq '>') {
  145.         ($code,$tmp,$string) = unpack("CCa99",$string);
  146.         if ($tmp[$[] > $code) {
  147.         $tmp[$[] += $tmp;
  148.         }
  149.     }
  150.     elsif ($code eq '2') {
  151.         $result .= sprintf("%02d",shift(@tmp));
  152.         $online = !$online;
  153.     }
  154.     elsif ($code eq '3') {
  155.         $result .= sprintf("%03d",shift(@tmp));
  156.         $online = !$online;
  157.     }
  158.     elsif ($code eq 'i') {
  159.         ($code,$tmp) = @tmp;
  160.         @tmp = ($code+1,$tmp+1);
  161.     }
  162.     else {
  163.         return "OOPS";
  164.     }
  165.     }
  166.     $result . $string . $after;
  167. }
  168.  
  169. 1;
  170.